home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 2 / Tech Arsenal 2 (Arsenal Computer).iso / clipper / s93bsp.exe / CL5 / CUSTYPFN.PRG < prev    next >
Encoding:
Text File  |  1993-11-26  |  7.3 KB  |  275 lines
  1. ///////////////////////////////////////////////////////////////
  2. //
  3. //  Module : CUSTYPFN.PRG
  4. //
  5. //  Created by SUMMER'93 (c) on Fri Nov 26 14:51:17 1993
  6. //
  7. ///////////////////////////////////////////////////////////////
  8. #include "snj.ch"
  9. // The following statics were declared 'PUBLIC' in the S87 code
  10. // OR were private and inherited by called functions
  11. // If they are used outside this module there will be a set/get
  12. // function with the same name as the var in this module
  13. static CTFLDS [ 2 ], CTHDRS [ 2 ]
  14. procedure CTEDIT( top, left, NROWS, MODE ) // Amended by SUMMER93
  15. // Calls: 
  16. // Called By: HOUSEMAIN VCUSTTYP 
  17. //       C T E D I T
  18. //       Routine to process Customer Classifications
  19. //    Last change:  MIB  26 Oct 93    5:51 pm
  20.  
  21. local CTFUNC, OLDSCR, WIDTH
  22. // do CTEDIT with TOP, LEFT, NROWS, MODE
  23.  
  24.  
  25. save screen to OLDSCR 
  26. select 0 
  27. use CUSTTYPE alias CUSTTYPE 
  28. WIDTH := 40 
  29. CTFUNC := iif( MODE  = 0, "CTSLCT", "CTUPDATE" )
  30.  
  31. CTHDRS[ 1 ] := "Code" 
  32. CTFLDS[ 1 ] := "CUSTTYPE" 
  33. CTHDRS[ 2 ] := "Description" 
  34. CTFLDS[ 2 ] := "CUSTDESC" 
  35. set deleted on 
  36. @ top, left, top + NROWS - 1, left + WIDTH box replicate( chr(177 ), 9 )
  37. @ top + 1, left + 2 clear to top + NROWS - 2, left + WIDTH - 2 
  38. select CUSTTYPE 
  39. go top 
  40. set color to( COLBRIGHT() )
  41. do while !GETOUT() 
  42.     dbedit( top + 1, left + 2, top + NROWS - 2, left + WIDTH - 2, CTFLDS, ;
  43.     CTFUNC, .t., CTHDRS, chr(196 ), chr(179 ))
  44. enddo 
  45.  
  46. GETOUT( .f.  )
  47. restore screen from OLDSCR 
  48. select CUSTTYPE 
  49. pack 
  50. index on FIELD->CUSTTYPE to CUSTTYPE 
  51. use 
  52. return 
  53.  
  54. //**********************************************************************
  55.  
  56. function CTSLCT( MODE, FLD_PTR ) // Amended by SUMMER93
  57. // Calls: QBYESNO CTPRMT2 
  58. // Called By: 
  59. // The following locals have been declared by Summer'93
  60. // ROWNO COLNO 
  61. local CURREC, CURFLD, MEDSTR, ROWNO, COLNO
  62.  
  63. CURREC := recno( )
  64. ROWNO := row( )
  65. COLNO := col( )
  66.  
  67. QBKEY( lastkey( ) )
  68. clear typeahead 
  69. do case 
  70.     case MODE < 4 
  71.         return 1 
  72.     case QBKEY()  = 27 .or. QBKEY()  = 3 
  73.         
  74.         MCUSTTYP( ""  )
  75.         MCDESC( ""  )
  76.         GETOUT( .t.  )
  77.         return 0 
  78.     case QBKEY()  = 13 
  79.         save screen 
  80.         CURFLD := CTFLDS[ FLD_PTR ] 
  81.         MEDSTR := FIELD->CUSTTYPE ->&CURFLD 
  82.         set color to( COLFLASH() )
  83.         @ ROWNO, COLNO say MEDSTR 
  84.         if QBYESNO( "Select this Type? (Y/N)" ) = "Y" 
  85.             MCUSTTYP( FIELD->CUSTTYPE ->CUSTTYPE  )
  86.             MCDESC( FIELD->CUSTTYPE ->CUSTDESC  )
  87.             GETOUT( .t.  )
  88.             return 0 
  89.         endif 
  90.         set color to( COLBRIGHT() )
  91.         restore screen 
  92.     otherwise 
  93.         clear typeahead 
  94.         do CTPRMT2
  95.         return 1 
  96. endcase 
  97.  
  98. return 0 
  99. //**********************************************************************
  100.  
  101. function CTUPDATE( MODE, FLD_PTR ) // Amended by SUMMER93
  102. // Calls: CTPRMT1 QBYESNO QBPROMPT QBREAD 
  103. // Called By: 
  104. // The following locals have been declared by Summer'93
  105. // ROWNO COLNO ACTION PICSTR 
  106. local SCRBOT, CURREC, GO_REC, CURFLD, MEDSTR, GETLIST, ROWNO, COLNO, ACTION;
  107. , PICSTR
  108. GETLIST := {}
  109.  
  110. CURREC := recno( )
  111. ROWNO := row( )
  112. COLNO := col( )
  113.  
  114. do CTPRMT1
  115. QBKEY( lastkey( ) )
  116. if QBKEY()  = 27 
  117.     GETOUT( .t.  )
  118. endif 
  119.  
  120. do case 
  121.     case( MODE  = 2 .or. MODE  = 3 ) // Past top or bottom
  122.         if QBYESNO( "Add new Customer Type?" ) = "Y" 
  123.             QBRESP( "E"  )
  124.             go bottom 
  125.             append blank 
  126.             ROWNO := ROWNO + 1 
  127.         else 
  128.             do CTPRMT1
  129.             return 1 
  130.         endif 
  131.     case MODE < 4 
  132.         return 1 
  133.     case QBKEY()  = 13 
  134.         save screen 
  135.         CURFLD := CTFLDS[ FLD_PTR ] 
  136.         MEDSTR := FIELD->CUSTTYPE ->&CURFLD 
  137.         set color to( COLFLASH() )
  138.         @ ROWNO, COLNO say MEDSTR 
  139.         QBRESP( iif( QBYESNO("Edit this line?" ) = "Y", "E", "I" ) )
  140.         set color to( COLBRIGHT() )
  141.         restore screen 
  142.     case QBKEY()  =  - 9  // F10
  143.         ACTION := QBPROMPT( "Ignore|Edit|Delete|Restore deletions|Quit|", "", ;
  144.         2 )
  145.     case QBKEY()  = 27 
  146.         QBRESP( "Q"  )
  147.     otherwise 
  148.         QBRESP( "E"  )
  149.         keyboard chr( QBKEY() )
  150. endcase 
  151.  
  152. CURFLD := CTFLDS[ FLD_PTR ] 
  153. MEDSTR := FIELD->CUSTTYPE ->&CURFLD 
  154.  
  155. do case 
  156.     case QBRESP()  = "E"  // Normal Selection by CR
  157.         PICSTR := iif( len(MEDSTR )< 10, replicate("!", len(MEDSTR )), ;
  158.         replicate("X", len(MEDSTR )))
  159.  
  160.         @ ROWNO, COLNO get MEDSTR picture PICSTR 
  161.         do QBREAD with "Enter Information" , , GETLIST
  162.         // Call amended
  163.         if CHANGED() .and. !GETOUT() 
  164.             replace &CURFLD with MEDSTR 
  165.         endif 
  166.     case QBRESP()  = "Q" 
  167.         GETOUT( ( QBYESNO("Finished editing Customer types?" ) = "Y" ) )
  168.     case QBRESP()  = "D" 
  169.         save screen 
  170.         set color to( COLFLASH() )
  171.         @ ROWNO, COLNO say MEDSTR 
  172.         if QBYESNO( "Delete this Customer type?" ) = "Y" 
  173.             delete 
  174.         endif 
  175.         set color to( COLBRIGHT() )
  176.         restore screen 
  177.         do CTPRMT1
  178.         skip - 1 
  179.         skip 
  180.         return 2 
  181.     case QBRESP()  = "R" 
  182.         set deleted off 
  183.         recall all for deleted( )
  184.         set deleted on 
  185.         do CTPRMT1
  186.         return 2 
  187.     otherwise 
  188.         GETOUT( .f.  )
  189. endcase 
  190.  
  191. keyboard iif( FLD_PTR  = 1, chr(4 ), chr(19 ))
  192. set color to( COLBRIGHT() )
  193.  
  194. return iif( GETOUT() , 0, 1 )
  195.  
  196. //**********************************************************************
  197.  
  198. procedure CTPRMT1
  199. // Calls: QBCLMESS 
  200. // Called By: CTUPDATE 
  201. //       CTPRMT1
  202. local m
  203.  
  204. do QBCLMESS
  205. set color to( COLBRIGHT() )
  206. m := "Move with " + chr( 24 ) + chr( 25 ) + ". Scroll PgUp/PgDn. Exit: ESC." 
  207. @ QBMSGLIN() , centre( m, 80 )say m 
  208. m := [Hit "F10" for Command: Edit, Delete, Restore, Quit] 
  209. @ QBMSGLIN()  + 1, centre( m, 80 )say m 
  210.  
  211. return 
  212.  
  213. //**********************************************************************
  214.  
  215. procedure CTPRMT2
  216. // Calls: QBCLMESS 
  217. // Called By: CTSLCT INVOWNGT IVFUNC 
  218. //       CTPRMT2
  219. local m
  220.  
  221. do QBCLMESS
  222. set color to( COLBRIGHT() )
  223. m := "Move with " + chr( 24 ) + chr( 25 ) + ". Scroll PgUp/PgDn. " + chr( 17 );
  224.  + chr( 217 ) + [ to Select, ESC to Abort] 
  225. @ QBMSGLIN() , centre( m, 80 )say m 
  226.  
  227. return 
  228.  
  229. //**********************************************************************
  230.  
  231. function VCUSTTYP( R, C, BLANKOK ) // Amended by SUMMER93
  232. // Calls: CTEDIT 
  233. // Called By: REPARAM INVPAY 
  234. //       Return .t if Customer type is present or blank
  235. local RETVAL, MEM, VARNAME
  236.  
  237.  
  238. set softseek off 
  239. VARNAME := readvar()
  240. // SUMMER93 - Caution
  241. // A call to 'readvar' followed by a macro can 
  242. // be replaced by use of 'getactive' and 'varget'
  243. // VARNAME := GETACTIVE():VARGET()
  244. MEM := &VARNAME 
  245. if empty( MEM ).and. BLANKOK 
  246.     MCUSTTYP( blank( MCUSTTYP() ) )
  247.     MCDESC( blank( MCDESC() ) )
  248.     return .t. 
  249. endif 
  250.  
  251. select 0 
  252. use CUSTTYPE index CUSTTYPE alias CUSTTYPE 
  253.  
  254. seek MEM 
  255. if eof( )
  256.     clear typeahead 
  257.     do CTEDIT with 3, 37, 9, 0 
  258.     MEM := iif( GETOUT() , blank(MEM ), MCUSTTYP() )
  259. else 
  260.     MEM := CUSTTYPE->CUSTTYPE 
  261.     
  262.     MCUSTTYP( CUSTTYPE->CUSTTYPE  )
  263.     MCDESC( FIELD->CUSTTYPE ->CUSTDESC  )
  264. endif 
  265. set color to( COLBRIGHT() )
  266. @ R, C say MEM 
  267. set color to( COLNORM() )
  268. use 
  269.  
  270. return .t. 
  271.  
  272. //*****************************************************************
  273.  
  274. // End of file
  275.